VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cSystray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
' Module    : cSystray
' DateTime  : 05/07/2007 17:48
' Author    : Cobein
' Mail      : cobein27@yahoo.com
' Purpose   : Systray icon wrapper.
'           Note: There are more functions and events, but they are OS specifics (XP SP2,Vista), but I think
'           this class have everything you need to work so, Im not gonna add any of them.
'
'Updated: 7-7-7
'       Added Balloon timeout
'       Balloon Nosound
'       Changed the recovery function thanks to LaVolpe
'       Some bugs fixed
'
'Updated: 11-7-7
'       Major rewrite, additions and bug fixes, added support for windowless projects, class arrays
'       windows 9x balloon, 3 new methods to load icons from resource files, from files and to
'       extract them from dlls, exes. Fixed the balloontimeout and problems with popup menus.
'
'Updated: 16-7-7
'       Bug concerning recovery function fixed, if you are using the old version please replace it!
'       Thanks to:
'       LaVolpe, Carlos Alberto S. and Body_of_Rays for bug reports, ideas, code samples and support.
'---------------------------------------------------------------------------------------
Option Explicit

'=======================================================================================
' Self subclass and callback declarations
' I removed the comments and unused constants (original code txtCodeId=68737)
'=======================================================================================
Private z_IDEflag           As Long         'Flag indicating we are in IDE
Private z_ScMem             As Long         'Thunk base address
Private z_scFunk            As Collection   'hWnd/thunk-address collection
Private z_hkFunk            As Collection   'hook/thunk-address collection
Private z_cbFunk            As Collection   'callback/thunk-address collection
Private Const IDX_INDEX     As Long = 2     'index of the subclassed hWnd OR hook type
Private Const IDX_CALLBACKORDINAL As Long = 22 ' Ubound(callback thunkdata)+1, index of the callback

' Declarations:
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long

Private Enum eThunkType
    SubclassThunk = 0
    HookThunk = 1
    CallbackThunk = 2
End Enum

'-Selfsub specific declarations----------------------------------------------------------------------------
Private Enum eMsgWhen                                                   'When to callback
  MSG_BEFORE = 1                                                        'Callback before the original WndProc
  MSG_AFTER = 2                                                         'Callback after the original WndProc
  MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER                            'Callback before and after the original WndProc
End Enum

Private Const IDX_WNDPROC   As Long = 9     'Thunk data index of the original WndProc
Private Const IDX_BTABLE    As Long = 11    'Thunk data index of the Before table
Private Const IDX_ATABLE    As Long = 12    'Thunk data index of the After table
Private Const IDX_PARM_USER As Long = 13    'Thunk data index of the User-defined callback parameter data index
Private Const IDX_UNICODE   As Long = 75    'Must be Ubound(subclass thunkdata)+1; index for unicode support
Private Const ALL_MESSAGES  As Long = -1    'All messages callback
Private Const MSG_ENTRIES   As Long = 32    'Number of msg table entries. Set to 1 if using ALL_MESSAGES for all subclassed windows

' \\LaVolpe - Added non-ANSI version API calls
Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CallWindowProcW Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SendMessageA Lib "user32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function SendMessageW Lib "user32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowLongW Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'=======================================================================================
' End self subclass and callback declarations
'=======================================================================================

'// Windows messages
Private Const WM_MOUSEMOVE                                  As Long = &H200
Private Const WM_RBUTTONDBLCLK                              As Long = &H206
Private Const WM_RBUTTONDOWN                                As Long = &H204
Private Const WM_RBUTTONUP                                  As Long = &H205
Private Const WM_MBUTTONDBLCLK                              As Long = &H209
Private Const WM_MBUTTONDOWN                                As Long = &H207
Private Const WM_MBUTTONUP                                  As Long = &H208
Private Const WM_LBUTTONDBLCLK                              As Long = &H203
Private Const WM_LBUTTONDOWN                                As Long = &H201
Private Const WM_LBUTTONUP                                  As Long = &H202
Private Const WM_USER                                       As Long = &H400

'// Balloon messges
Private Const NIN_BALLOONSHOW                               As Long = (WM_USER + 2)
Private Const NIN_BALLOONHIDE                               As Long = (WM_USER + 3)
Private Const NIN_BALLOONTIMEOUT                            As Long = (WM_USER + 4)
Private Const NIN_BALLOONUSERCLICK                          As Long = (WM_USER + 5)

'// Tray update commands
Private Const NIM_ADD                                       As Long = &H0
Private Const NIM_DELETE                                    As Long = &H2
Private Const NIM_MODIFY                                    As Long = &H1
Private Const NIM_SETFOCUS                                  As Long = &H3
Private Const NIM_SETVERSION                                As Long = &H4

'// Tray update masks
Private Const NIF_ICON                                      As Long = &H2
Private Const NIF_INFO                                      As Long = &H10
Private Const NIF_MESSAGE                                   As Long = &H1
Private Const NIF_STATE                                     As Long = &H8
Private Const NIF_TIP                                       As Long = &H4

'// No sound flag
Private Const NIIF_NOSOUND                                  As Long = &H10

'// Window message
Private Const TASKBARMESSAGE                                As String = "TaskbarCreated"

'Private Const NIS_HIDDEN                                    As Long = &H1
'Private Const NIS_SHAREDICON                                As Long = &H2

'// Tray version settings
Private Const NOTIFYICON_VERSION                            As Long = &H3
Private Const NOTIFYICONDATA_V1_SIZE                        As Long = 88  'pre-5.0 structure size
Private Const NOTIFYICONDATA_V2_SIZE                        As Long = 488 'pre-6.0 structure size
Private Const NOTIFYICONDATA_V3_SIZE                        As Long = 504 '6.0+ structure size

'// Load icon
Private Const LR_LOADFROMFILE                               As Long = &H10
Private Const LR_LOADMAP3DCOLORS                            As Long = &H1000
Private Const LR_SHARED                                     As Long = &H8000&
Private Const IMAGE_ICON                                    As Long = 1

'// Notify data struct
Private Type NOTIFYICONDATA
   cbSize As Long
   hwnd As Long
   uID As Long
   uFlags As Long
   uCallbackMessage As Long
   hIcon As Long
   szTip As String * 128      'shell 5+  <> 64 chars max for shell <5
   dwState As Long            'shell 5+  <> not used in this class
   dwStateMask As Long        'shell 5+
   szInfo As String * 256     'shell 5+
   uTimeoutAndVersion As Long 'shell 5+
   szInfoTitle As String * 64 'shell 5+
   dwInfoFlags As Long        'shell 5+
   guidItem(15) As Byte       ' GUID  shell 6+  <> reserved by Windows
End Type

'// Icon type
Public Enum ttIconType
    TTNoIcon = 0
    TTIconInfo = 1
    TTIconWarning = 2
    TTIconError = 3
    TTIconUser = 4
End Enum

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" ( _
    ByVal dwMessage As Long, _
    ByRef lpData As NOTIFYICONDATA) As Long
'// Window creation
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" ( _
    ByVal dwExStyle As Long, _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String, _
    ByVal dwStyle As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hWndParent As Long, _
    ByVal hMenu As Long, _
    ByVal hInstance As Long, _
    lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" ( _
    ByVal hwnd As Long) As Long
'// Timer
Private Declare Function SetTimer Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal nIDEvent As Long, _
    ByVal uElapse As Long, _
    ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal nIDEvent As Long) As Long
'// Window message
Private Declare Function RegisterWindowMessage Lib "user32.dll" Alias "RegisterWindowMessageA" ( _
    ByVal lpString As String) As Long
'//
Private Declare Function SetForegroundWindow Lib "user32" ( _
    ByVal hwnd As Long) As Long
'// Load Icon
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" ( _
    ByVal hInst As Long, _
    ByVal lpsz As String, _
    ByVal dwImageType As Long, _
    ByVal dwDesiredWidth As Long, _
    ByVal dwDesiredHeight As Long, _
    ByVal dwFlags As Long) As Long
Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" ( _
    ByVal lpszFile As String, _
    ByVal nIconIndex As Long, _
    phiconLarge As Long, _
    phiconSmall As Long, _
    ByVal nIcons As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
    ByVal hObject As Long) As Long
'// Determine Version Info
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    pDst As Any, _
    pSrc As Any, _
    ByVal ByteLen As Long)
Private Declare Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" ( _
    ByVal lptstrFilename As String, _
    lpdwHandle As Long) As Long
Private Declare Function GetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoA" ( _
    ByVal lptstrFilename As String, _
    ByVal dwHandle As Long, _
    ByVal dwLen As Long, _
    lpData As Any) As Long
Private Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" ( _
    pBlock As Any, _
    ByVal lpSubBlock As String, _
    lpBuffer As Any, _
    nVerSize As Long) As Long
'//Callback
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, _
    ByVal hwnd As Long, _
    ByVal msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long

'Events
Public Event MouseMove()
Public Event MouseDown(Button As Integer)
Public Event MouseUp(Button As Integer)
Public Event MouseDblClick(Button As Integer)
Public Event BalloonClose()
Public Event BalloonClick()
Public Event BalloonShow()
Public Event BalloonHide()

'Member variables
Private c_lhWnd As Long
Private c_NIcData As NOTIFYICONDATA
Private c_sToolTip As String
Private c_lIcon As Long
Private c_sTitle As String
Private c_sText As String
Private c_Icon As ttIconType
Private c_bIconVisible As Boolean
Private c_lTm As Long
Private c_lHRIcon As Long
Private NOTIFYICONDATA_SIZE As Long
Private c_lTimeOut As Long
Private c_lProc As Long
Private c_lExtraParam As Long

'---------------------------------------------------------------------------------------
' Procedure : SetProc
' Purpose   : Set the callback proc for windowless projects
'---------------------------------------------------------------------------------------
Public Sub SetProc(ByVal lProc As Long)
    c_lProc = lProc
End Sub
'---------------------------------------------------------------------------------------
' Procedure : lhWnd
' Purpose   : Handle of our subclassed window, the only purpose of this is to identify
'             the class when you create an array
'---------------------------------------------------------------------------------------
Public Function lhWnd() As Long
    lhWnd = c_lhWnd
End Function
'---------------------------------------------------------------------------------------
' Procedure : ExtraParam
' Purpose   : This extra param will be passed to the callback as a wParam, the only purpose
'             of this is to identify the class when you create an array
'---------------------------------------------------------------------------------------
Public Property Let ExtraParam(ByVal lVal As Long)
    c_lExtraParam = lVal
End Property
'---------------------------------------------------------------------------------------
' Procedure : ExtraParam
' Purpose   : Returns the extra param value
'---------------------------------------------------------------------------------------
Public Property Get ExtraParam() As Long
    ExtraParam = c_lExtraParam
End Property
'---------------------------------------------------------------------------------------
' Procedure : Class_Initialize
' Purpose   : Initialize class
'---------------------------------------------------------------------------------------
Private Sub Class_Initialize()
    If NOTIFYICONDATA_SIZE = 0 Then GetTrayVersion 'Determine shell version
    c_lhWnd = CreateWindowEx(0, "STATIC", vbNullString, _
       0, 0, 0, 0, 0, 0, 0, App.hInstance, 0) 'Create a window to receive the events
    c_lTm = RegisterWindowMessage(TASKBARMESSAGE) 'Get the "TaskbarCreated" message value
    If ssc_Subclass(c_lhWnd, , 1) Then 'Subclass the window
        ssc_AddMsg c_lhWnd, WM_MOUSEMOVE, MSG_AFTER
        ssc_AddMsg c_lhWnd, c_lTm, MSG_AFTER
    End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : Class_Terminate
' Purpose   : Cleanup
'---------------------------------------------------------------------------------------
Private Sub Class_Terminate()
    SysTrayShow False       'Remove systray Icon
    DeleteObject c_lHRIcon  'Delete Icon object
    ssc_Terminate           'Terminate subclass
    DestroyWindow c_lhWnd   'Destroy our window
    scb_TerminateCallbacks  'Terminate Callback
End Sub
'---------------------------------------------------------------------------------------
' Procedure : SysTrayShow
' Purpose   : Create or destroy the systray icon
'---------------------------------------------------------------------------------------
Public Sub SysTrayShow(Optional ByVal bShow As Boolean = True)
    If bShow Then
        With c_NIcData
            If Not c_bIconVisible Then
                .cbSize = NOTIFYICONDATA_SIZE
                .uTimeoutAndVersion = NOTIFYICON_VERSION
                .hwnd = c_lhWnd
                .uID = ObjPtr(Me)
                .uFlags = NIF_MESSAGE
                .uCallbackMessage = WM_MOUSEMOVE
            End If
            
            .uFlags = NIF_MESSAGE
                            
            If Not c_lIcon = 0 Then
                .uFlags = .uFlags Or NIF_ICON
                .hIcon = c_lIcon
            End If
                
            If Not c_sToolTip = vbNullString Then
                .uFlags = .uFlags Or NIF_TIP
                .szTip = c_sToolTip & vbNullChar
            End If
            
        End With
        
        If Not c_bIconVisible Then
            Shell_NotifyIcon NIM_ADD, c_NIcData
            c_bIconVisible = True
        Else
            Shell_NotifyIcon NIM_MODIFY, c_NIcData
        End If
        c_bIconVisible = True
    Else
        If c_bIconVisible Then
            KillTimer c_lhWnd, ObjPtr(Me) + 1
            Shell_NotifyIcon NIM_DELETE, c_NIcData
            c_bIconVisible = False
        End If
    End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : BalloonShow
' Purpose   : Create or destroy the balloon if its possible
'           lTimeout = timeout for the ballon (millisecs). Default -1 do not use timer to destroy the ballon
'           Returns False if ballon is not supported also you can use the funtion IsBalloonCapable to check it
'---------------------------------------------------------------------------------------
Public Function BalloonShow( _
       Optional ByVal bShow As Boolean = True, _
       Optional ByVal lTimeout As Long = -1, _
       Optional ByVal bNoSound As Boolean = False) As Boolean
    
    If NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE Then
        If bShow Then
            BalloonShow False
            With c_NIcData
                c_lTimeOut = lTimeout
                .uFlags = NIF_INFO
                .szInfo = c_sText & vbNullChar
                .szInfoTitle = c_sTitle & vbNullChar
                .dwInfoFlags = c_Icon
                If bNoSound Then
                    .dwInfoFlags = .dwInfoFlags Or NIIF_NOSOUND
                End If
            End With
            Shell_NotifyIcon NIM_MODIFY, c_NIcData
        Else
            With c_NIcData
                .uFlags = NIF_INFO
                .szInfo = vbNullChar
                .szInfoTitle = vbNullChar
            End With
            Shell_NotifyIcon NIM_MODIFY, c_NIcData
            KillTimer c_lhWnd, ObjPtr(Me) + 1
        End If
        BalloonShow = True
    End If
    
End Function
'---------------------------------------------------------------------------------------
' Procedure : IsBalloonCapable
' Purpose   : will let you know if you can use balloons on clients pc
'---------------------------------------------------------------------------------------
Public Property Get IsBalloonCapable() As Boolean
    IsBalloonCapable = (NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE)
End Property
'---------------------------------------------------------------------------------------
' Procedure : BeforePopup
' Purpose   : Call this function before showing a popupmenu to prevent it from getting stuck
'---------------------------------------------------------------------------------------
Public Sub BeforePopup()
    Call SetForegroundWindow(c_lhWnd)
End Sub
'---------------------------------------------------------------------------------------
' Procedure : SysTrayIconFromHandle
' Purpose   : Set the icon from handle
'---------------------------------------------------------------------------------------
Public Function SysTrayIconFromHandle(ByVal lIcon As Long)
    'you are responsible for destroying this icon if needed
    c_lIcon = lIcon
    If c_bIconVisible Then
        With c_NIcData
            .uFlags = NIF_ICON
            .hIcon = c_lIcon
        End With
        Shell_NotifyIcon NIM_MODIFY, c_NIcData
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : SysTrayIconFromFile
' Purpose   : Set the icon from a file
'---------------------------------------------------------------------------------------
Public Function SysTrayIconFromFile(ByVal sFile As String) As Boolean
    'The icon will be destroyed if you load a new one or if the class is terminated
    DeleteObject c_lHRIcon
    
    c_lHRIcon = LoadImage(App.hInstance, sFile, IMAGE_ICON, _
       16, 16, LR_LOADFROMFILE Or LR_LOADMAP3DCOLORS Or LR_SHARED)

    If Not c_lHRIcon = 0 Then
        SysTrayIconFromHandle c_lHRIcon
        SysTrayIconFromFile = True
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : SysTrayIconFromRes
' Purpose   : Set the icon from resource
'             IMPORTANT: Compile the project to use this function.
'---------------------------------------------------------------------------------------
Public Function SysTrayIconFromRes(ByVal sResName As String) As Boolean
    'The icon will be destroyed if you load a new one or if the class is terminated
    DeleteObject c_lHRIcon
    
    c_lHRIcon = LoadImage(App.hInstance, sResName, IMAGE_ICON, _
       16, 16, LR_SHARED Or LR_LOADMAP3DCOLORS)

    If Not c_lHRIcon = 0 Then
        SysTrayIconFromHandle c_lHRIcon
        SysTrayIconFromRes = True
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : SysTrayIconFromCompRes
' Purpose   : Set the icon from a dll or exe
'           sResFile: path of the file
'           lIconIndex: index of the icon
'---------------------------------------------------------------------------------------
Public Function SysTrayIconFromCompRes( _
       ByVal sResFile As String, _
       ByVal lIconIndex As Long) As Boolean
    'The icon will be destroyed if you load a new one or if the class is terminated
    DeleteObject c_lHRIcon
    
    Call ExtractIconEx(sResFile, lIconIndex, c_lHRIcon, ByVal 0&, 1)

    If Not c_lHRIcon = 0 Then
        SysTrayIconFromHandle c_lHRIcon
        SysTrayIconFromCompRes = True
    End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : SysTrayToolTip
' Purpose   : get the current tooltip
'---------------------------------------------------------------------------------------
Public Property Get SysTrayToolTip() As String
    SysTrayToolTip = c_sToolTip
End Property
'---------------------------------------------------------------------------------------
' Procedure : SysTrayToolTip
' Purpose   : Set the tooltip of our icon
'---------------------------------------------------------------------------------------
Public Property Let SysTrayToolTip(ByVal New_ToolTip As String)
    c_sToolTip = Trim$(New_ToolTip)
    With c_NIcData
        .uFlags = NIF_TIP
        .szTip = c_sToolTip & vbNullChar
    End With
    Shell_NotifyIcon NIM_MODIFY, c_NIcData
End Property
'---------------------------------------------------------------------------------------
' Procedure : BalloonIcon
' Purpose   : Get the icon type of the balloon
'---------------------------------------------------------------------------------------
Public Property Get BalloonIcon() As ttIconType
    BalloonIcon = c_Icon
End Property
'---------------------------------------------------------------------------------------
' Procedure : BalloonIcon
' Purpose   : Set the icon type for the balloon
'---------------------------------------------------------------------------------------
Public Property Let BalloonIcon(Icon As ttIconType)
    If NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE Then
        c_Icon = Icon
        With c_NIcData
            .uFlags = NIF_INFO Or NIF_TIP
            .dwInfoFlags = c_Icon
        End With
        Shell_NotifyIcon NIM_MODIFY, c_NIcData
    End If
End Property
'---------------------------------------------------------------------------------------
' Procedure : BalloonTitle
' Purpose   : Get the balloon title
'---------------------------------------------------------------------------------------
Public Property Get BalloonTitle() As String
    BalloonTitle = c_sTitle
End Property
'---------------------------------------------------------------------------------------
' Procedure : BalloonTitle
' Purpose   : Set the balloon title
'---------------------------------------------------------------------------------------
Public Property Let BalloonTitle(sTitle As String)
    If NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE Then
        c_sTitle = sTitle
        With c_NIcData
            .uFlags = NIF_INFO Or NIF_TIP
            .szInfoTitle = c_sTitle & vbNullChar
        End With
        Shell_NotifyIcon NIM_MODIFY, c_NIcData
    End If
End Property
'---------------------------------------------------------------------------------------
' Procedure : BalloonText
' Purpose   : Get the ballon text
'---------------------------------------------------------------------------------------
Public Property Get BalloonText() As String
    BalloonText = c_sText
End Property
'---------------------------------------------------------------------------------------
' Procedure : BalloonText
' Purpose   : Set the balloon text
'---------------------------------------------------------------------------------------
Public Property Let BalloonText(sText As String)
    If NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE Then
        c_sText = sText
        With c_NIcData
            .uFlags = NIF_INFO Or NIF_TIP
            .szInfo = c_sText & vbNullChar
        End With
        Shell_NotifyIcon NIM_MODIFY, c_NIcData
    End If
End Property
'---------------------------------------------------------------------------------------
' Procedure : GetTrayVersion
' Purpose   : Get shell version
'---------------------------------------------------------------------------------------
Private Sub GetTrayVersion()
    ' unmodified from source

    'returns True if the Shell version
    '(shell32.dll) is equal or later than
    'the value passed as 'version'
    Dim nBufferSize As Long
    Dim nUnused As Long
    Dim lpBuffer As Long
    Dim nVerMajor As Integer
    Dim bBuffer() As Byte
   
    Const sDLLFile As String = "shell32.dll"
    nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused)
   
    If nBufferSize > 0 Then
        ReDim bBuffer(nBufferSize - 1) As Byte
        Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0))
        If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then
            CopyMemory nVerMajor, ByVal lpBuffer + 10, 2
            'IsShellVersion = nVerMajor >= version
            Select Case nVerMajor
                Case Is < 5
                    NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE
                Case Is < 6
                    NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V2_SIZE
                Case Else
                    NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V3_SIZE
            End Select
        End If  'VerQueryValue
    End If  'nBufferSize
  
End Sub

'-The following routines are exclusively for the ssc_subclass routines----------------------------
Private Function ssc_Subclass(ByVal lng_hWnd As Long, _
       Optional ByVal lParamUser As Long = 0, _
       Optional ByVal nOrdinal As Long = 1, _
       Optional ByVal oCallback As Object = Nothing, _
       Optional ByVal bIdeSafety As Boolean = True, _
       Optional ByVal bUnicode As Boolean = False) As Boolean 'Subclass the specified window handle

    '*************************************************************************************************
    '* lng_hWnd   - Handle of the window to subclass
    '* lParamUser - Optional, user-defined callback parameter
    '* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
    '* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
    '* bIdeSafety - Optional, enable/disable IDE safety measures. NB: you should really only disable IDE safety in a UserControl for design-time subclassing
    '* bUnicode - Optional, if True, Unicode API calls will be made to the window vs ANSI calls
    '*************************************************************************************************
    '* cSelfSub - self-subclassing class template
    '* Paul_Caton@hotmail.com
    '* Copyright free, use and abuse as you see fit.
    '*
    '* v1.0 Re-write of the SelfSub/WinSubHook-2 submission to Planet Source Code............ 20060322
    '* v1.1 VirtualAlloc memory to prevent Data Execution Prevention faults on Win64......... 20060324
    '* v1.2 Thunk redesigned to handle unsubclassing and memory release...................... 20060325
    '* v1.3 Data array scrapped in favour of property accessors.............................. 20060405
    '* v1.4 Optional IDE protection added
    '*      User-defined callback parameter added
    '*      All user routines that pass in a hWnd get additional validation
    '*      End removed from zError.......................................................... 20060411
    '* v1.5 Added nOrdinal parameter to ssc_Subclass
    '*      Switched machine-code array from Currency to Long................................ 20060412
    '* v1.6 Added an optional callback target object
    '*      Added an IsBadCodePtr on the callback address in the thunk prior to callback..... 20060413
    '*************************************************************************************************
    ' Subclassing procedure must be declared identical to the one at the end of this class (Sample at Ordinal #1)

    ' \\LaVolpe - reworked routine a bit, revised the ASM to allow auto-unsubclass on WM_DESTROY
    Dim z_Sc(0 To IDX_UNICODE) As Long                 'Thunk machine-code initialised here
    Const CODE_LEN      As Long = 4 * IDX_UNICODE      'Thunk length in bytes
    
    Const MEM_LEN       As Long = CODE_LEN + (8 * (MSG_ENTRIES))  'Bytes to allocate per thunk, data + code + msg tables
    Const PAGE_RWX      As Long = &H40&                'Allocate executable memory
    Const MEM_COMMIT    As Long = &H1000&              'Commit allocated memory
    Const MEM_RELEASE   As Long = &H8000&              'Release allocated memory flag
    Const IDX_EBMODE    As Long = 3                    'Thunk data index of the EbMode function address
    Const IDX_CWP       As Long = 4                    'Thunk data index of the CallWindowProc function address
    Const IDX_SWL       As Long = 5                    'Thunk data index of the SetWindowsLong function address
    Const IDX_FREE      As Long = 6                    'Thunk data index of the VirtualFree function address
    Const IDX_BADPTR    As Long = 7                    'Thunk data index of the IsBadCodePtr function address
    Const IDX_OWNER     As Long = 8                    'Thunk data index of the Owner object's vTable address
    Const IDX_CALLBACK  As Long = 10                   'Thunk data index of the callback method address
    Const IDX_EBX       As Long = 16                   'Thunk code patch index of the thunk data
    Const GWL_WNDPROC   As Long = -4                   'SetWindowsLong WndProc index
    Const WNDPROC_OFF   As Long = &H38                 'Thunk offset to the WndProc execution address
    Const SUB_NAME      As String = "ssc_Subclass"     'This routine's name
    
    Dim nAddr         As Long
    Dim nID           As Long
    Dim nMyID         As Long

    If IsWindow(lng_hWnd) = 0 Then                      'Ensure the window handle is valid
        zError SUB_NAME, "Invalid window handle"
        Exit Function
    End If
    
    nMyID = GetCurrentProcessId                         'Get this process's ID
    GetWindowThreadProcessId lng_hWnd, nID              'Get the process ID associated with the window handle
    If nID <> nMyID Then                                'Ensure that the window handle doesn't belong to another process
        zError SUB_NAME, "Window handle belongs to another process"
        Exit Function
    End If
      
    If oCallback Is Nothing Then Set oCallback = Me     'If the user hasn't specified the callback owner
    
    nAddr = zAddressOf(oCallback, nOrdinal)             'Get the address of the specified ordinal method
    If nAddr = 0 Then                                   'Ensure that we've found the ordinal method
        zError SUB_NAME, "Callback method not found"
        Exit Function
    End If
        
    z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
    
    If z_ScMem <> 0 Then                                  'Ensure the allocation succeeded
  
        If z_scFunk Is Nothing Then Set z_scFunk = New Collection 'If this is the first time through, do the one-time initialization
        On Error GoTo CatchDoubleSub                              'Catch double subclassing
        z_scFunk.Add z_ScMem, "h" & lng_hWnd                    'Add the hWnd/thunk-address to the collection
        On Error GoTo 0
        
        ' \\Tai Chi Minh Ralph Eastwood - fixed bug where the MSG_AFTER was not being honored
        ' \\LaVolpe - modified thunks to allow auto-unsubclassing when WM_DESTROY received
        z_Sc(14) = &HD231C031: z_Sc(15) = &HBBE58960: z_Sc(16) = &H12345678: z_Sc(17) = &HF63103FF: z_Sc(18) = &H750C4339: z_Sc(19) = &H7B8B4A38: z_Sc(20) = &H95E82C: z_Sc(21) = &H7D810000: z_Sc(22) = &H228&: z_Sc(23) = &HC70C7500: z_Sc(24) = &H20443: z_Sc(25) = &H5E90000: z_Sc(26) = &H39000000: z_Sc(27) = &HF751475: z_Sc(28) = &H25E8&: z_Sc(29) = &H8BD23100: z_Sc(30) = &H6CE8307B: z_Sc(31) = &HFF000000: z_Sc(32) = &H10C2610B: z_Sc(33) = &HC53FF00: z_Sc(34) = &H13D&: z_Sc(35) = &H85BE7400: z_Sc(36) = &HE82A74C0: z_Sc(37) = &H2&: z_Sc(38) = &H75FFE5EB: z_Sc(39) = &H2C75FF30: z_Sc(40) = &HFF2875FF: z_Sc(41) = &H73FF2475: z_Sc(42) = &H1053FF24: z_Sc(43) = &H811C4589: z_Sc(44) = &H13B&: z_Sc(45) = &H39727500:
        z_Sc(46) = &H6D740473: z_Sc(47) = &H2473FF58: z_Sc(48) = &HFFFFFC68: z_Sc(49) = &H873FFFF: z_Sc(50) = &H891453FF: z_Sc(51) = &H7589285D: z_Sc(52) = &H3045C72C: z_Sc(53) = &H8000&: z_Sc(54) = &H8920458B: z_Sc(55) = &H4589145D: z_Sc(56) = &HC4816124: z_Sc(57) = &H4&: z_Sc(58) = &H8B1862FF: z_Sc(59) = &H853AE30F: z_Sc(60) = &H810D78C9: z_Sc(61) = &H4C7&: z_Sc(62) = &H28458B00: z_Sc(63) = &H2975AFF2: z_Sc(64) = &H2873FF52: z_Sc(65) = &H5A1C53FF: z_Sc(66) = &H438D1F75: z_Sc(67) = &H144D8D34: z_Sc(68) = &H1C458D50: z_Sc(69) = &HFF3075FF: z_Sc(70) = &H75FF2C75: z_Sc(71) = &H873FF28: z_Sc(72) = &HFF525150: z_Sc(73) = &H53FF2073: z_Sc(74) = &HC328C328
        
        z_Sc(IDX_EBX) = z_ScMem                                                 'Patch the thunk data address
        z_Sc(IDX_INDEX) = lng_hWnd                                               'Store the window handle in the thunk data
        z_Sc(IDX_BTABLE) = z_ScMem + CODE_LEN                                   'Store the address of the before table in the thunk data
        z_Sc(IDX_ATABLE) = z_ScMem + CODE_LEN + ((MSG_ENTRIES + 1) * 4)         'Store the address of the after table in the thunk data
        z_Sc(IDX_OWNER) = ObjPtr(oCallback)                                     'Store the callback owner's object address in the thunk data
        z_Sc(IDX_CALLBACK) = nAddr                                              'Store the callback address in the thunk data
        z_Sc(IDX_PARM_USER) = lParamUser                                        'Store the lParamUser callback parameter in the thunk data
        
        ' \\LaVolpe - validate unicode request & cache unicode usage
        If bUnicode Then bUnicode = (IsWindowUnicode(lng_hWnd) <> 0&)
        z_Sc(IDX_UNICODE) = bUnicode                                            'Store whether the window is using unicode calls or not
        
        ' \\LaVolpe - added extra parameter "bUnicode" to the zFnAddr calls
        z_Sc(IDX_FREE) = zFnAddr("kernel32", "VirtualFree", bUnicode)           'Store the VirtualFree function address in the thunk data
        z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr", bUnicode)        'Store the IsBadCodePtr function address in the thunk data
        
        Debug.Assert zInIDE
        If bIdeSafety = True And z_IDEflag = 1 Then                             'If the user wants IDE protection
            z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode", bUnicode)                'Store the EbMode function address in the thunk data
        End If
    
        ' \\LaVolpe - use ANSI for non-unicode usage, else use WideChar calls
        If bUnicode Then
            z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcW", bUnicode)          'Store CallWindowProc function address in the thunk data
            z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongW", bUnicode)           'Store the SetWindowLong function address in the thunk data
            z_Sc(IDX_UNICODE) = 1
            RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
            nAddr = SetWindowLongW(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
        Else
            z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcA", bUnicode)          'Store CallWindowProc function address in the thunk data
            z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongA", bUnicode)           'Store the SetWindowLong function address in the thunk data
            RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
            nAddr = SetWindowLongA(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
        End If
        If nAddr = 0 Then                                                           'Ensure the new WndProc was set correctly
            zError SUB_NAME, "SetWindowLong failed, error #" & Err.LastDllError
            GoTo ReleaseMemory
        End If
        'Store the original WndProc address in the thunk data
        RtlMoveMemory z_ScMem + IDX_WNDPROC * 4, VarPtr(nAddr), 4&              ' z_Sc(IDX_WNDPROC) = nAddr
        ssc_Subclass = True                                                     'Indicate success
    Else
        zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
    End If

    Exit Function                                                             'Exit ssc_Subclass
    
CatchDoubleSub:
    zError SUB_NAME, "Window handle is already subclassed"
      
ReleaseMemory:
    VirtualFree z_ScMem, 0, MEM_RELEASE                                       'ssc_Subclass has failed after memory allocation, so release the memory
End Function

'Terminate all subclassing
Private Sub ssc_Terminate()
    ' can be made public. Releases all subclassing
    ' can be removed and zTerminateThunks can be called directly
    zTerminateThunks SubclassThunk
End Sub

'UnSubclass the specified window handle
Private Sub ssc_UnSubclass(ByVal lng_hWnd As Long)
    ' can be made public. Releases a specific subclass
    ' can be removed and zUnThunk can be called directly
    zUnThunk lng_hWnd, SubclassThunk
End Sub

'Add the message value to the window handle's specified callback table
Private Sub ssc_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
    ' Note: can be removed if not needed and zAddMsg can be called directly
    If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then                 'Ensure that the thunk hasn't already released its memory
        If When And MSG_BEFORE Then                                             'If the message is to be added to the before original WndProc table...
            zAddMsg uMsg, IDX_BTABLE                                              'Add the message to the before table
        End If
        If When And MSG_AFTER Then                                              'If message is to be added to the after original WndProc table...
            zAddMsg uMsg, IDX_ATABLE                                              'Add the message to the after table
        End If
    End If
End Sub

'Delete the message value from the window handle's specified callback table
Private Sub ssc_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
    ' Note: can be removed if not needed and zDelMsg can be called directly
    If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then                'Ensure that the thunk hasn't already released its memory
        If When And MSG_BEFORE Then                                             'If the message is to be deleted from the before original WndProc table...
            zDelMsg uMsg, IDX_BTABLE                                              'Delete the message from the before table
        End If
        If When And MSG_AFTER Then                                              'If the message is to be deleted from the after original WndProc table...
            zDelMsg uMsg, IDX_ATABLE                                              'Delete the message from the after table
        End If
    End If
End Sub

'Call the original WndProc
Private Function ssc_CallOrigWndProc(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    ' Note: can be removed if you do not use this function inside of your window procedure
    If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then            'Ensure that the thunk hasn't already released its memory
        If zData(IDX_UNICODE) Then
            ssc_CallOrigWndProc = CallWindowProcW(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
        Else
            ssc_CallOrigWndProc = CallWindowProcA(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
        End If
    End If
End Function

'Get the subclasser lParamUser callback parameter
Private Function zGet_lParamUser(ByVal hWnd_Hook_ID As Long, vType As eThunkType) As Long
    'Note: can be removed if you never need to retrieve/update your user-defined paramter. See ssc_Subclass
    If vType <> CallbackThunk Then
        If IsBadCodePtr(zMap_VFunction(hWnd_Hook_ID, vType)) = 0 Then        'Ensure that the thunk hasn't already released its memory
            zGet_lParamUser = zData(IDX_PARM_USER)                                'Get the lParamUser callback parameter
        End If
    End If
End Function

'Let the subclasser lParamUser callback parameter
Private Sub zSet_lParamUser(ByVal hWnd_Hook_ID As Long, vType As eThunkType, newValue As Long)
    'Note: can be removed if you never need to retrieve/update your user-defined paramter. See ssc_Subclass
    If vType <> CallbackThunk Then
        If IsBadCodePtr(zMap_VFunction(hWnd_Hook_ID, vType)) = 0 Then          'Ensure that the thunk hasn't already released its memory
            zData(IDX_PARM_USER) = newValue                                         'Set the lParamUser callback parameter
        End If
    End If
End Sub

'Add the message to the specified table of the window handle
Private Sub zAddMsg(ByVal uMsg As Long, ByVal nTable As Long)
    Dim nCount As Long                                                        'Table entry count
    Dim nBase  As Long                                                        'Remember z_ScMem
    Dim i      As Long                                                        'Loop index
    
    nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
    z_ScMem = zData(nTable)                                                   'Map zData() to the specified table
    
    If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being added to the table...
        nCount = ALL_MESSAGES                                                   'Set the table entry count to ALL_MESSAGES
    Else
        nCount = zData(0)                                                       'Get the current table entry count
        If nCount >= MSG_ENTRIES Then                                           'Check for message table overflow
            zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTRIES or use ALL_MESSAGES instead of specific message values"
            GoTo Bail
        End If
    
        For i = 1 To nCount                                                     'Loop through the table entries
            If zData(i) = 0 Then                                                  'If the element is free...
                zData(i) = uMsg                                                     'Use this element
                GoTo Bail                                                           'Bail
            ElseIf zData(i) = uMsg Then                                           'If the message is already in the table...
                GoTo Bail                                                           'Bail
            End If
        Next i                                                                  'Next message table entry
    
        nCount = i                                                              'On drop through: i = nCount + 1, the new table entry count
        zData(nCount) = uMsg                                                    'Store the message in the appended table entry
    End If
    
    zData(0) = nCount                                                         'Store the new table entry count
Bail:
    z_ScMem = nBase                                                           'Restore the value of z_ScMem
End Sub

'Delete the message from the specified table of the window handle
Private Sub zDelMsg(ByVal uMsg As Long, ByVal nTable As Long)
    Dim nCount As Long                                                        'Table entry count
    Dim nBase  As Long                                                        'Remember z_ScMem
    Dim i      As Long                                                        'Loop index
    
    nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
    z_ScMem = zData(nTable)                                                   'Map zData() to the specified table
    
    If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being deleted from the table...
        zData(0) = 0                                                            'Zero the table entry count
    Else
        nCount = zData(0)                                                       'Get the table entry count
        
        For i = 1 To nCount                                                     'Loop through the table entries
            If zData(i) = uMsg Then                                               'If the message is found...
                zData(i) = 0                                                        'Null the msg value -- also frees the element for re-use
                GoTo Bail                                                           'Bail
            End If
        Next i                                                                  'Next message table entry
        
        zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
    End If
      
Bail:
    z_ScMem = nBase                                                           'Restore the value of z_ScMem
End Sub

'-SelfCallback code------------------------------------------------------------------------------------
'-The following routines are exclusively for the scb_SetCallbackAddr routines----------------------------
Private Function scb_SetCallbackAddr(ByVal nParamCount As Long, _
       Optional ByVal nOrdinal As Long = 1, _
       Optional ByVal oCallback As Object = Nothing, _
       Optional ByVal bIdeSafety As Boolean = True) As Long   'Return the address of the specified callback thunk
    '*************************************************************************************************
    '* nParamCount  - The number of parameters that will callback
    '* nOrdinal     - Callback ordinal number, the final private method is ordinal 1, the second last is ordinal 2, etc...
    '* oCallback    - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
    '* bIdeSafety   - Optional, set to false to disable IDE protection.
    '*************************************************************************************************
    ' Callback procedure must return a Long even if, per MSDN, the callback procedure is a Sub vs Function
    ' The number of parameters are dependent on the individual callback procedures
    
    Const MEM_LEN     As Long = IDX_CALLBACKORDINAL * 4 + 4     'Memory bytes required for the callback thunk
    Const PAGE_RWX    As Long = &H40&                           'Allocate executable memory
    Const MEM_COMMIT  As Long = &H1000&                         'Commit allocated memory
    Const SUB_NAME      As String = "scb_SetCallbackAddr"       'This routine's name
    Const INDX_OWNER    As Long = 0
    Const INDX_CALLBACK As Long = 1
    Const INDX_EBMODE   As Long = 2
    Const INDX_BADPTR   As Long = 3
    Const INDX_EBX      As Long = 5
    Const INDX_PARAMS   As Long = 12
    Const INDX_PARAMLEN As Long = 17

    Dim z_Cb()    As Long    'Callback thunk array
    Dim nCallback As Long
      
    If z_cbFunk Is Nothing Then
        Set z_cbFunk = New Collection           'If this is the first time through, do the one-time initialization
    Else
        On Error Resume Next                    'Catch already initialized?
        z_ScMem = z_cbFunk.Item("h" & nOrdinal) 'Test it
        If Err = 0 Then
            scb_SetCallbackAddr = z_ScMem + 16  'we had this one, just reference it
            Exit Function
        End If
        On Error GoTo 0
    End If
    
    If nParamCount < 0 Then                     ' validate parameters
        zError SUB_NAME, "Invalid Parameter count"
        Exit Function
    End If
    
    If oCallback Is Nothing Then Set oCallback = Me     'If the user hasn't specified the callback owner
    nCallback = zAddressOf(oCallback, nOrdinal)         'Get the callback address of the specified ordinal
    If nCallback = 0 Then
        zError SUB_NAME, "Callback address not found."
        Exit Function
    End If
    z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
        
    If z_ScMem = 0& Then
        zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError  ' oops
        Exit Function
    End If
    z_cbFunk.Add z_ScMem, "h" & nOrdinal                  'Add the callback/thunk-address to the collection
        
    ReDim z_Cb(0 To IDX_CALLBACKORDINAL) As Long          'Allocate for the machine-code array
    
    ' Create machine-code array
    z_Cb(4) = &HBB60E089: z_Cb(6) = &H73FFC589: z_Cb(7) = &HC53FF04: z_Cb(8) = &H7B831F75: z_Cb(9) = &H20750008: z_Cb(10) = &HE883E889: z_Cb(11) = &HB9905004: z_Cb(13) = &H74FF06E3: z_Cb(14) = &HFAE2008D: z_Cb(15) = &H53FF33FF: z_Cb(16) = &HC2906104: z_Cb(18) = &H830853FF: z_Cb(19) = &HD87401F8: z_Cb(20) = &H4589C031: z_Cb(21) = &HEAEBFC
    
    z_Cb(INDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr", False)
    z_Cb(INDX_OWNER) = ObjPtr(oCallback)                  'Set the Owner
    z_Cb(INDX_CALLBACK) = nCallback                       'Set the callback address
    z_Cb(IDX_CALLBACKORDINAL) = nOrdinal                  'Cache ordinal used for zTerminateThunks
      
    Debug.Assert zInIDE
    If bIdeSafety = True And z_IDEflag = 1 Then             'If the user wants IDE protection
        z_Cb(INDX_EBMODE) = zFnAddr("vba6", "EbMode", False)  'EbMode Address
    End If
        
    z_Cb(INDX_PARAMS) = nParamCount                         'Set the parameter count
    z_Cb(INDX_PARAMLEN) = nParamCount * 4                   'Set the number of stck bytes to release on thunk return
      
    '\\LaVolpe - redirect address to proper location in virtual memory. Was: z_Cb(INDX_EBX) = VarPtr(z_Cb(INDX_OWNER))
    z_Cb(INDX_EBX) = z_ScMem                                'Set the data address relative to virtual memory pointer
      
    RtlMoveMemory z_ScMem, VarPtr(z_Cb(INDX_OWNER)), MEM_LEN 'Copy thunk code to executable memory
    scb_SetCallbackAddr = z_ScMem + 16                       'Thunk code start address
    
End Function

Private Sub scb_ReleaseCallback(ByVal nOrdinal As Long)
    ' can be made public. Releases a specific callback
    ' can be removed and zUnThunk can be called directly
    zUnThunk nOrdinal, CallbackThunk
End Sub
Private Sub scb_TerminateCallbacks()
    ' can be made public. Releases all callbacks
    ' can be removed and zTerminateThunks can be called directly
    zTerminateThunks CallbackThunk
End Sub


'========================================================================
' COMMON USE ROUTINES
'-The following routines are used for each of the three types of thunks
'========================================================================

'Map zData() to the thunk address for the specified window handle
Private Function zMap_VFunction(ByVal vFuncTarget As Long, vType As eThunkType) As Long
    
    ' vFuncTarget is one of the following, depending on vType
    '   - Subclassing:  the hWnd of the window subclassed
    '   - Hooking:      the hook type created
    '   - Callbacks:    the ordinal of the callback
    
    Dim thunkCol As Collection
    
    If vType = CallbackThunk Then
        Set thunkCol = z_cbFunk
    ElseIf vType = HookThunk Then
        Set thunkCol = z_hkFunk
    ElseIf vType = SubclassThunk Then
        Set thunkCol = z_scFunk
    Else
        zError "zMap_Vfunction", "Invalid thunk type passed"
        Exit Function
    End If
    
    If thunkCol Is Nothing Then
        zError "zMap_VFunction", "Thunk hasn't been initialized"
    Else
        On Error GoTo Catch
        z_ScMem = thunkCol("h" & vFuncTarget)                    'Get the thunk address
        zMap_VFunction = z_ScMem
    End If
    Exit Function                                               'Exit returning the thunk address
    
Catch:
    zError "zMap_VFunction", "Thunk type for ID of " & vFuncTarget & " does not exist"
End Function

'Error handler
Private Sub zError(ByVal sRoutine As String, ByVal sMsg As String)
    ' \\LaVolpe -  Note. These two lines can be rem'd out if you so desire. But don't remove the routine
    App.LogEvent TypeName(Me) & "." & sRoutine & "r each     nk type for ID of " & vFuncTarget & " pe fore)pate& ssssssssssLogEvDH(0        0      'Set th"p.Logicothe WndProc executiCpu(ta +uncT6uSet th"p.Logicothe WndProc executiCpu(ta +unou so dehe valuei   hunk ck ordinal     nk type fo the SetWindowsLong fe fo the SetWindowsLong fe f1ring = "scb_SeF the thunk wsLon22222222E,1 Private Su222222E,122222222E,22222E,1ll_Noti
 2E,22222E,1llllllhnkCol = z_e array2    nst INDX_PARAMLEN As Longap_VFunction = z_ScMem
. But      :b_SetCallIDX_WND71 pe fore)pate& sf vType =le
Pr7ogEven  'Bytemon =
        '    'Exit ssc_Subcl be MIDX_W       'Sdeter "bUniIallIDX_WND71 pe fore)pb


'========================================================================
' COMMON USE ROUTINES
'-Ru " & ========B'==========================s mIallIDX_WNi'Bytemo'-Ru " & ========B'Psic. s_Term.p_VFunction", .public. Releases all callbacks
    ' can bMz_ScMem
     ack aU     Set thun22E,22222E,1ll_Noti
 s String, ByVathe thunk data
            z_Scng = &oved andv-0        0      'Set th"p.k adda=    nApu(ta +uncTDDnt + pate&   'Set the table entryyyyyypg, ByVathe thunk L  ElseIf vType rt th release the memory
End Function

'Terminate all subcenOrdinal CallIDXMAGES
   le
    subcen                 'Set the data address relative to virtualdre   'Cac     a2                         'EbMode R routine
    App.LogEv   'Cacivate Sub INDX_EBXErt th release the mem8heWBPi   l As Long3cNl Is NotUMubcen
'-Ru " & ========B'===fer(0))
        I - 1) As Byte
        Call GetFileVersionI<      od
    If nAddr = 0 Then                                   'ERinal 1, the second last is ordinal 2, etc...
Ev   'CaciT     zMap_VFuhe mem ordinal 2, etc.ory
    em or th"dress of the specified ordinal
    If nCallback = 0 TAs Long, OptionallIDXMA9    If nCallbac        he mem wfOrotUMubcen
'-Ru37) = &H2&: z=====B'==========================s mIallIDX_WNi'Bhe 5,122222222E,2222he 5,1222, etcE,22222E0,5MMMMMMMMMMMMMM  #1)

 dstore tb(18) = &H
            z_===s mIallIDX_WNi'Bhe 5,122222222E,2222he5tiolMMMMMM  #1)
iyVat          
 2E,22 Parameter count"
 ,,,
    If nParamCounBhe 5MMM3RDines r     r7   If nPA,D   
 2EEEEEEEEEEE:cE,22ese two    z_Scng = &eIf vTy"scb_SeF    IText
' Purpose   : GRu37) = &ne Cat      :LastDllEal Bpk dptionallIDXMA9    If7aseMemory:
   ze two    z_ScllIDXMN3the isPA,D   
 2EEEEEEEEEEE:cE,22ese two cal BRallIDD   = zData(nTave the routine
    Ap    If cal BRallID memory
    s DX_PARAMLEN) = nParr(z_Cb(4)    Sr     5the routine
   'Set thhhhhhhhhhhhhhhhhhhhhhhhhhU       Irtualdre   '=====================================================

'Map zData() to the thunk address for the specified window handle
b))))))unk return
 c(0, code-------------------zDataE   IDX_Wur     5the r============s mIallIDX_WNi'BT is already subc7he r=== alIallIxW0ave the routine
    Ap     ,,,
en
'-RuP"IsBadC   nk (9) = &Ht to thEnce iM=====siub GetTrayVersion()
    ' unmodified from sourc()
      5the1   
    nBase = z_ScMem         zDataE sourc()
&********(0, codeEEEEEEEEE)))))unac     a2        1) As Byte
    Irtualdre   '===============c     ,,,back(ByVal nOrdinal As Long)
able o==========SodeEEEEEe+ 16  'we Ac(IDIs NotUMciT   ***(======SodciT   *l nOrdiHt to thEncF-zDataElt to thEncF-zDataElt to thEhEncF-zDatH2975Ahat wiiHt to thEncF-h, dddddddddOrdiHHHHHHHHHH)n,ChEn'al 1, the se*t wiiHt to thEncF-h, d)'* nPar-------------)) = ===========AhEnconst IND            o==AhEnconst INd last is ordinal 2, etc...
    '* oCallback    - Optional, the object that will receive the callback. If undefined, callbackthe kthe kthe kthe kthe kthe kthe kthe kthe kthe kt sou        rn thef u==c     indexrn a Long even if, per MSDN, the callback procedueataE       the  ==c    1f nCallback = 0 Thef this is thd directlyCt is one of the folloRlbackAddrCb(1O'* nPar-------------)    1f nCallback = 0 .453lback = 0 ThellIDXMA9   H4&:rhe kthe kthepCDN, (z_ScMem
     aO8 a Long even if, per MSDN, the callback procedure is a Sub u the se*t wiiHt z

'Me = z_ScMe callbllIDXMA9 trPtr(z_hhhhhhU      lback = 0, lbllIDMe car aO8 a Loback protring, h4&:rhe kthe kong even if, per MSDN

---feCONDATA_V1_SIZE
              
       1)
iyVat       l elemeIDXMAGES
   le
    suHHHH)n, u==c     indexrn a Long ) = &H53FF2073: z_Sc(74) = &HC328Uonst INstore itz_ScMem
     aO8 a Long even 1e itz_1     22ese two ress in th                                  p********"p.k addah  :rhe kthe kong evennarcMemt thBmt thBmt theCONDATA_V1_L     i"dow subc****************nk data
        RtlMov  Const IDUI   If nParamCou_V1_L     i"dddddddRv Ac(I even taEltse*t wiiHt z

' a Long ) = &H53FF2073: z_Sc(74)1ennarcMemt thBm& z

'Me = z_ScMe c.ethunk ada) = llIDMe ca     thBm& z

'Me = z_ScMe c.ethunk ada) = llIFess Adata

'Me = z_ScMe c.ethunk ada) = llz

' a28Uonst NDATAo  
    
'Me = z_ScMemt thBm& z

'Me emt thBm& z

E) = aers are dependent> Wn)n,ChEn'nst NDATAo  
  
 vTy &H53FF2073: z_Sarget object
   'Cacivate Sub INDX_EBXEbackthe ======e53FF2073: zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz3FF2073: b INDX_Eallback. If undefined, callbackth subclasseMSDN, the c  'Cacivate Sub IND llIFess A: z_Sarggggh is MMMMMMMMMe mem ordina) = llIDMe ca     thBm& z

'Me =et oCallback = Me     'IIIIIIIIIIIr)aENES
   'III65i =et oCacalled directly
    zUnThunk nOrdinal, Cal Else
    ealled          callFet theOphhhhU    CuuuuuuuuuuuuuuuuuuuMh     N, t nOrdinal, Cal Else
    eeive th9u Else

'M  scb_Setf table entry count
              D llIFess A: z_Sarggggh     ehhhhU    CuuuuuuuuuuuuuuuuuuuMh     N, t nOrdinal, CrUnThuac nOrdi(6) =o1)
hBm& z

'Me el/uuuMh    s in the thunk data
       iT   ***(======ethunkh8m>n, sois already subc7he r=== alIallm        bc7he r=89C031: z_Cb(21) = &HEAEBFC
    
hm           2z_ScMem8(46) = &Hb     'Remember z_a  As  codeEEEEEEEEE))r z_a  As  codeEEEEEEEEE))r z_a  As  codeEElse

'MATAooop index
    
    nBase = z_ScMem                 ssllm  dependent> EElse
il
a GoTo Catcn't spendent
' a28Uonst NDAVFunction(BMer MSDNnIf vType = SubclassThunk Then
        Set thunk    
hm           2******1g Then oEachingA", bUnicode)      hunk return
      
unk    
hm        gA", bUnicoecif1
' a28U'he w1  1f nCallbaz_a  As  codeEEEEEEEEE))r z_a  As  codeEElse

'MATAooop index
a28U'he 5 thunk ction

'Error handler
Privatebl******* atck return
      
unk BECacalled directly
    zUnop inde_Cb(0 To IDX_CALLBACKORDINAL) As LSsDD   = zData(nTave the routineoecif1even taEltse*t wiiHzzzzBT         'EnoeadyMr7wind
a28U'he 5 thunk ction

'Error handler
Privatebl******* a5 thunk ction

'Error handler
Privatebl******* a5 thunk ction

'Erroe SSDN, tho222E,1llOLtck return
  Next te the Ptr(zMap_VFunction(lng_hWnd, SubclassThuCW     'Get the address of the ssalled directly
    zTermiiiiiiiiC3("kernel32"z